unit RaSqliteRout;

interface

uses SysUtils;

const
  vtcIdentifier = 1;
  vtcNumber = 2;
  vtcAssignment = 3;
  vtcQString = 4;
  vtcDString = 5;
  vtcRelOp = 6;
  vtcFloat = 7;
  vtcDelimiter = 8;
  vtcEof = 9;

procedure FindErrorPos(InString: string; ErrPos: integer;
  var TheLine, TheCol: integer);
function GetWord(var InString: string; var StartPos: integer;
  var VarType: integer): string;
function GetWordByDelim(var InString: string; var StartPos: integer;
  var Delim: string): string;
function PeekWord(var InString: string; StartPos: integer;
  var VarType: integer): string;
function Recover(var InString: string; var StartPos: integer): boolean;
function StrToIntX(StrIn: string): integer;
function StrToFloatX(StrIn : string) : extended;
function StrToDateX(TheDate: string): TDateTime;
function StrToDateTimeX(const S: string): TDateTime;
function YYYYMMDDParser(Str: PChar): TDateTime;
function FloatParser(Str: string): string;

implementation

function FloatParser(Str: string): string;
var
  Point: Byte;
begin
  if  DecimalSeparator <> '.'  then  begin
    Point := Pos ('.', Str);
    if  Point <> 0
    then  Str[Point] := DecimalSeparator;
  end;
  Result := Str;
end;

function StrToDateTimeX(const S: string): TDateTime;
begin
  if S = '' then
     StrToDateTimeX := 0
  else begin
     try
        StrToDateTimeX := StrToDateTime(S);
     except
        StrToDateTimeX := StrToDateX(s);
     end;
  end;
end;

function StrToDateX(TheDate: string): TDateTime;
var
  DateFormat: string;
  DateSep:    char;
begin
  DateFormat := ShortDateFormat;
  DateSep    := DateSeparator;
  try
    try
      StrToDateX      := StrToDate(TheDate)
    except
      DateSeparator   := '-';
      ShortDateFormat := 'dd-mm-yyyy';
      try
        StrToDateX      := StrToDate(TheDate)
      except
        ShortDateFormat := 'yyyy-mm-dd';
        try
          StrToDateX := StrToDate(TheDate)
        except
          StrToDateX := StrToDateX('01-01-1900');
          raise;
        end;
      end;
    end;
  finally
    ShortDateFormat := DateFormat;
    DateSeparator   := DateSep;
  end;
end;

function YYYYMMDDParser(Str: PChar): TDateTime;
var
  Year, Month, Day, Hour, Min, Sec, MSec: Word;
begin
  Result := 0;

  try
    if Length(Str) >= 10 then
    begin
      Year := StrToInt(Copy(Str, 1, 4));
      Month := StrToInt(Copy(Str, 6, 2));
      Day := StrToInt(Copy(Str, 9, 2));

      Result := EncodeDate(Year, Month, Day);
    end;

    if Length(Str) > 10 then
    begin
      Hour := StrToInt(Copy(Str, 12, 2));
      Min := StrToInt(Copy(Str, 15, 2));
      Sec := 0;
      MSec := 0;
      if Length(Str) > 16 then Sec := StrToInt(Copy(Str, 18, 2));
      if Length(Str) > 19 then Msec := StrToInt(Copy(Str, 21, 3));
      Result := Result + EncodeTime(Hour, Min, Sec, MSec);
    end;
  except
    Result := 0;
  end;
end;

function StrToIntX(StrIn: string): integer;
var
E: Integer;
begin
 Val(StrIn, Result, E);
 if E <> 0 then Result := 0;
end;

function StrToFloatX(StrIn : string) : extended;
begin
  if not TextToFloat(PChar(StrIn), Result, fvExtended) then
  Result := 0;
end;

procedure FindErrorPos(InString: string; ErrPos: integer;
  var TheLine, TheCol: integer);
var
  i: integer;
begin
  TheLine := 1;
  TheCol := 1;
  i := 1;
  while i < ErrPos do
  begin
    if InString[i] in [ #10, #13] then
    begin
      Inc(TheLine);
      TheCol := 1;
      Inc(i);
      Inc(i);
    end
    else
    begin
      Inc(TheCol);
      Inc(i);
    end;
  end;
end;

function Recover(var InString: string;
  var StartPos: integer): boolean;
begin
  if (StartPos > Length(InString)) then
  begin
    Recover := false;
    exit;
  end;

  while (Startpos < Length(InString)) and
    ( not (InString[StartPos] in [ #10, #13])) do
    Inc(StartPos);
  Recover := true;
end;

function PeekWord(var InString: string; StartPos: integer;
  var VarType: integer): string;
begin
  PeekWord := GetWord(InString, StartPos, VarType);
end;

function GetWordByDelim(var InString: string;
  var StartPos: integer;
  var Delim: string): string;
var
  Ret: string;
begin
  Ret := '';
  while (StartPos <= Length(InString)) and (InString[StartPos] = ' ') do
    Inc(StartPos);
  while (StartPos <= Length(InString)) and (Pos(InString[StartPos], Delim) = 0) do
  begin
    Ret := Ret + InString[StartPos];
    Inc(StartPos);
  end;
  GetWordByDelim := Trim(Ret);
end;

function GetWord(var InString: string; var StartPos: integer;
  var VarType: integer): string;
var
  TheChar: char;
  Rv:      string;
begin
  if (StartPos > Length(InString)) then
  begin
    GetWord := '';
    VarType := vtcEof;
    exit;
  end;

  while (StartPos <= Length(InString)) and (InString[StartPos] <= #32) do
    Inc(StartPos);

  TheChar := InString[StartPos];
  Rv      := '';

  if TheChar in ['a'..'z', 'A'..'Z'] then
    VarType := vtcIdentifier
  else if TheChar in ['0'..'9', '-'] then
    VarType := vtcNumber
  else if TheChar = ':' then
    VarType := vtcAssignment
  else if TheChar = '"' then
    VarType := vtcDString
  else if TheChar = '''' then
    VarType := vtcQString
  else if TheChar in ['>', '=', '<'] then
    VarType := vtcRelOp
  else
  begin
    Inc(StartPos);
    if TheChar = '!' then
    begin
      Recover(InString, StartPos);
      Rv      := GetWord(InString, StartPos, VarType);
      GetWord := Rv;
    end
    else
    begin
      GetWord := TheChar;
    end;
    exit;
  end;

  case VarType of
    vtcIdentifier:
    begin
      while InString[StartPos] in ['a'..'z', 'A'..'Z', '_','0'..'9'] do
      begin
        Rv := Rv + InString[StartPos];
        Inc(StartPos);
      end;
    end;
    vtcNumber:
    begin
      while InString[StartPos] in ['-', '0'..'9', '.'] do
      begin
        if InString[StartPos] = '.' then
          VarType := vtcFloat;
        Rv := Rv + InString[StartPos];
        Inc(StartPos);
      end;
      if VarType = vtcFloat then
        Rv := FloatToStr(StrToFloat(Rv))
      else
        Rv := IntToStr(StrToInt(Rv));
    end;
    vtcAssignment:
    begin
      Rv := InString[StartPos];
      Inc(StartPos);
      if InString[StartPos] = '=' then
      begin
        Inc(StartPos);
        Rv := ':=';
      end
      else
      begin
        VarType := vtcDelimiter;
        Rv      := ':';
      end;
    end;
    vtcQString:
    begin
      Inc(StartPos);
      while InString[StartPos] <> '''' do
      begin
        Rv := Rv + InString[StartPos];
        Inc(StartPos);
      end;
      Inc(StartPos);
    end;
    vtcDString:
    begin
      Inc(StartPos);
      while InString[StartPos] <> '"' do
      begin
        Rv := Rv + InString[StartPos];
        Inc(StartPos);
      end;
      Inc(StartPos);
    end;
    vtcRelOp:
    begin
      Rv := InString[StartPos];
      if Rv = '<' then
      begin
        if InString[StartPos + 1] in ['=', '>'] then
        begin
          Rv := Rv + InString[StartPos + 1];
          StartPos := StartPos + 2;
        end
        else
        begin
          Inc(StartPos);
        end;
      end
      else if Rv = '>' then
      begin
        if InString[StartPos + 1] in ['=', '<'] then
        begin
          Rv := Rv + InString[StartPos + 1];
          StartPos := StartPos + 2;
        end
        else
        begin
          Inc(StartPos);
        end;
      end
      else
      begin
        Inc(StartPos);
      end;
    end;
  end;
  GetWord := Rv;
end;

end.
